home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl-5.003.tar.gz / perl-5.003.tar / perl-5.003 / lib / dumpvar.pl < prev    next >
Perl Script  |  1996-02-12  |  11KB  |  409 lines
  1. require 5.002;            # For (defined ref)
  2. package dumpvar;
  3.  
  4. # Needed for PrettyPrinter only:
  5.  
  6. # require 5.001;  # Well, it coredumps anyway undef DB in 5.000 (not now)
  7.  
  8. # translate control chars to ^X - Randal Schwartz
  9. # Modifications to print types by Peter Gordon v1.0
  10.  
  11. # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  12.  
  13. # Won't dump symbol tables and contents of debugged files by default
  14.  
  15. $winsize = 80 unless defined $winsize;
  16.  
  17.  
  18. # Defaults
  19.  
  20. # $globPrint = 1;
  21. $printUndef = 1 unless defined $printUndef;
  22. $tick = "auto" unless defined $tick;
  23. $unctrl = 'quote' unless defined $unctrl;
  24. $subdump = 1;
  25.  
  26. sub main::dumpValue {
  27.   local %address;
  28.   (print "undef\n"), return unless defined $_[0];
  29.   (print &stringify($_[0]), "\n"), return unless ref $_[0];
  30.   dumpvar::unwrap($_[0],0);
  31. }
  32.  
  33. # This one is good for variable names:
  34.  
  35. sub unctrl {
  36.     local($_) = @_;
  37.     local($v) ; 
  38.  
  39.     return \$_ if ref \$_ eq "GLOB";
  40.     s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  41.     $_;
  42. }
  43.  
  44. sub stringify {
  45.     local($_,$noticks) = @_;
  46.     local($v) ; 
  47.     my $tick = $tick;
  48.  
  49.     return 'undef' unless defined $_ or not $printUndef;
  50.     return $_ . "" if ref \$_ eq 'GLOB';
  51.     if ($tick eq 'auto') {
  52.       if (/[\000-\011\013-\037\177]/) {
  53.         $tick = '"';
  54.       }else {
  55.         $tick = "'";
  56.       }
  57.     }
  58.     if ($tick eq "'") {
  59.       s/([\'\\])/\\$1/g;
  60.     } elsif ($unctrl eq 'unctrl') {
  61.       s/([\"\\])/\\$1/g ;
  62.       s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  63.       s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
  64.         if $quoteHighBit;
  65.     } elsif ($unctrl eq 'quote') {
  66.       s/([\"\\\$\@])/\\$1/g if $tick eq '"';
  67.       s/\033/\\e/g;
  68.       s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
  69.     }
  70.     s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
  71.     ($noticks || /^\d+(\.\d*)?\Z/) 
  72.       ? $_ 
  73.       : $tick . $_ . $tick;
  74. }
  75.  
  76. sub ShortArray {
  77.   my $tArrayDepth = $#{$_[0]} ; 
  78.   $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 
  79.     unless  $arrayDepth eq '' ; 
  80.   my $shortmore = "";
  81.   $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
  82.   if (!grep(ref $_, @{$_[0]})) {
  83.     $short = "0..$#{$_[0]}  '" . 
  84.       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  85.     return $short if length $short <= $compactDump;
  86.   }
  87.   undef;
  88. }
  89.  
  90. sub DumpElem {
  91.   my $short = &stringify($_[0], ref $_[0]);
  92.   if ($veryCompact && ref $_[0]
  93.       && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
  94.     my $end = "0..$#{$v}  '" . 
  95.       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  96.   } elsif ($veryCompact && ref $_[0]
  97.       && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
  98.     my $end = 1;
  99.       $short = $sp . "0..$#{$v}  '" . 
  100.         join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
  101.   } else {
  102.     print "$short\n";
  103.     unwrap($_[0],$_[1]);
  104.   }
  105. }
  106.  
  107. sub unwrap {
  108.     return if $DB::signal;
  109.     local($v) = shift ; 
  110.     local($s) = shift ; # extra no of spaces
  111.     local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ;
  112.     local($tHashDepth,$tArrayDepth) ;
  113.  
  114.     $sp = " " x $s ;
  115.     $s += 3 ; 
  116.  
  117.     # Check for reused addresses
  118.     if (ref $v) { 
  119.       ($address) = $v =~ /(0x[0-9a-f]+)/ ; 
  120.       if (defined $address) { 
  121.     ($type) = $v =~ /=(.*?)\(/ ;
  122.     $address{$address}++ ;
  123.     if ( $address{$address} > 1 ) { 
  124.       print "${sp}-> REUSED_ADDRESS\n" ; 
  125.       return ; 
  126.     } 
  127.       }
  128.     } elsif (ref \$v eq 'GLOB') {
  129.       $address = "$v" . "";    # To avoid a bug with globs
  130.       $address{$address}++ ;
  131.       if ( $address{$address} > 1 ) { 
  132.     print "${sp}*DUMPED_GLOB*\n" ; 
  133.     return ; 
  134.       } 
  135.     }
  136.  
  137.     if ( ref $v eq 'HASH' or $type eq 'HASH') { 
  138.     @sortKeys = sort keys(%$v) ;
  139.     undef $more ; 
  140.     $tHashDepth = $#sortKeys ; 
  141.     $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
  142.       unless $hashDepth eq '' ; 
  143.     $more = "....\n" if $tHashDepth < $#sortKeys ; 
  144.     $shortmore = "";
  145.     $shortmore = ", ..." if $tHashDepth < $#sortKeys ; 
  146.     $#sortKeys = $tHashDepth ; 
  147.     if ($compactDump && !grep(ref $_, values %{$v})) {
  148.       #$short = $sp . 
  149.       #  (join ', ', 
  150. # Next row core dumps during require from DB on 5.000, even with map {"_"}
  151.       #   map {&stringify($_) . " => " . &stringify($v->{$_})} 
  152.       #   @sortKeys) . "'$shortmore";
  153.       $short = $sp;
  154.       my @keys;
  155.       for (@sortKeys) {
  156.         push @keys, &stringify($_) . " => " . &stringify($v->{$_});
  157.       }
  158.       $short .= join ', ', @keys;
  159.       $short .= $shortmore;
  160.       (print "$short\n"), return if length $short <= $compactDump;
  161.     }
  162.     for $key (@sortKeys) {
  163.         return if $DB::signal;
  164.         $value = $ {$v}{$key} ;
  165.         print "$sp", &stringify($key), " => ";
  166.         DumpElem $value, $s;
  167.     }
  168.     print "$sp  empty hash\n" unless @sortKeys;
  169.     print "$sp$more" if defined $more ;
  170.     } elsif ( ref $v eq 'ARRAY' or $type eq 'ARRAY') { 
  171.     $tArrayDepth = $#{$v} ; 
  172.     undef $more ; 
  173.     $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
  174.       unless  $arrayDepth eq '' ; 
  175.     $more = "....\n" if $tArrayDepth < $#{$v} ; 
  176.     $shortmore = "";
  177.     $shortmore = " ..." if $tArrayDepth < $#{$v} ;
  178.     if ($compactDump && !grep(ref $_, @{$v})) {
  179.       if ($#$v >= 0) {
  180.         $short = $sp . "0..$#{$v}  " . 
  181.           join(" ", 
  182.            map {stringify $_} @{$v}[0..$tArrayDepth])
  183.         . "$shortmore";
  184.       } else {
  185.         $short = $sp . "empty array";
  186.       }
  187.       (print "$short\n"), return if length $short <= $compactDump;
  188.     }
  189.     #if ($compactDump && $short = ShortArray($v)) {
  190.     #  print "$short\n";
  191.     #  return;
  192.     #}
  193.     for $num ($[ .. $tArrayDepth) {
  194.         return if $DB::signal;
  195.         print "$sp$num  ";
  196.         DumpElem $v->[$num], $s;
  197.     }
  198.     print "$sp  empty array\n" unless @$v;
  199.     print "$sp$more" if defined $more ;  
  200.     } elsif ( ref $v eq 'SCALAR' or ref $v eq 'REF' or $type eq 'SCALAR' ) { 
  201.         print "$sp-> ";
  202.         DumpElem $$v, $s;
  203.     } elsif ( ref $v eq 'CODE' or $type eq 'CODE' ) { 
  204.         print "$sp-> ";
  205.         dumpsub (0, $v);
  206.     } elsif (ref $v eq 'GLOB') {
  207.       print "$sp-> ",&stringify($$v,1),"\n";
  208.       if ($globPrint) {
  209.     $s += 3;
  210.     dumpglob($s, "{$$v}", $$v, 1);
  211.       } elsif (defined ($fileno = fileno($v))) {
  212.     print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
  213.       }
  214.     } elsif (ref \$v eq 'GLOB') {
  215.       if ($globPrint) {
  216.     dumpglob($s, "{$v}", $v, 1) if $globPrint;
  217.       } elsif (defined ($fileno = fileno(\$v))) {
  218.     print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
  219.       }
  220.     }
  221. }
  222.  
  223. sub matchvar {
  224.   $_[0] eq $_[1] or 
  225.     ($_[1] =~ /^([!~])(.)/) and 
  226.       ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$'/});
  227. }
  228.  
  229. sub compactDump {
  230.   $compactDump = shift if @_;
  231.   $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
  232.   $compactDump;
  233. }
  234.  
  235. sub veryCompact {
  236.   $veryCompact = shift if @_;
  237.   compactDump(1) if !$compactDump and $veryCompact;
  238.   $veryCompact;
  239. }
  240.  
  241. sub unctrlSet {
  242.   if (@_) {
  243.     my $in = shift;
  244.     if ($in eq 'unctrl' or $in eq 'quote') {
  245.       $unctrl = $in;
  246.     } else {
  247.       print "Unknown value for `unctrl'.\n";
  248.     }
  249.   }
  250.   $unctrl;
  251. }
  252.  
  253. sub quote {
  254.   if (@_ and $_[0] eq '"') {
  255.     $tick = '"';
  256.     $unctrl = 'quote';
  257.   } elsif (@_ and $_[0] eq 'auto') {
  258.     $tick = 'auto';
  259.     $unctrl = 'quote';
  260.   } elsif (@_) {        # Need to set
  261.     $tick = "'";
  262.     $unctrl = 'unctrl';
  263.   }
  264.   $tick;
  265. }
  266.  
  267. sub dumpglob {
  268.     return if $DB::signal;
  269.     my ($off,$key, $val, $all) = @_;
  270.     local(*entry) = $val;
  271.     my $fileno;
  272.     if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
  273.       print( (' ' x $off) . "\$", &unctrl($key), " = " );
  274.       DumpElem $entry, 3+$off;
  275.     }
  276.     if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
  277.       print( (' ' x $off) . "\@$key = (\n" );
  278.       unwrap(\@entry,3+$off) ;
  279.       print( (' ' x $off) .  ")\n" );
  280.     }
  281.     if ($key ne "main::" && $key ne "DB::" && defined %entry
  282.     && ($dumpPackages or $key !~ /::$/)
  283.     && ($key !~ /^_</ or $dumpDBFiles)
  284.     && !($package eq "dumpvar" and $key eq "stab")) {
  285.       print( (' ' x $off) . "\%$key = (\n" );
  286.       unwrap(\%entry,3+$off) ;
  287.       print( (' ' x $off) .  ")\n" );
  288.     }
  289.     if (defined ($fileno = fileno(*entry))) {
  290.       print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
  291.     }
  292.     if ($all) {
  293.       if (defined &entry) {
  294.     dumpsub($off, $key);
  295.       }
  296.     }
  297. }
  298.  
  299. sub dumpsub {
  300.     my ($off,$sub) = @_;
  301.     $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
  302.     my $subref = \&$sub;
  303.     my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
  304.       || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
  305.     $place = '???' unless defined $place;
  306.     print( (' ' x $off) .  "&$sub in $place\n" );
  307. }
  308.  
  309. sub findsubs {
  310.   return undef unless defined %DB::sub;
  311.   my ($addr, $name, $loc);
  312.   while (($name, $loc) = each %DB::sub) {
  313.     $addr = \&$name;
  314.     $subs{"$addr"} = $name;
  315.   }
  316.   $subdump = 0;
  317.   $subs{ shift() };
  318. }
  319.  
  320. sub main::dumpvar {
  321.     my ($package,@vars) = @_;
  322.     local(%address,$key,$val);
  323.     $package .= "::" unless $package =~ /::$/;
  324.     *stab = *{"main::"};
  325.     while ($package =~ /(\w+?::)/g){
  326.       *stab = $ {stab}{$1};
  327.     }
  328.     local $TotalStrings = 0;
  329.     local $Strings = 0;
  330.     local $CompleteTotal = 0;
  331.     while (($key,$val) = each(%stab)) {
  332.       return if $DB::signal;
  333.       next if @vars && !grep( matchvar($key, $_), @vars );
  334.       if ($usageOnly) {
  335.     globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
  336.       } else {
  337.     dumpglob(0,$key, $val);
  338.       }
  339.     }
  340.     if ($usageOnly) {
  341.       print "String space: $TotalStrings bytes in $Strings strings.\n";
  342.       $CompleteTotal += $TotalStrings;
  343.       print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
  344.     }
  345. }
  346.  
  347. sub scalarUsage {
  348.   my $size = length($_[0]);
  349.   $TotalStrings += $size;
  350.   $Strings++;
  351.   $size;
  352. }
  353.  
  354. sub arrayUsage {        # array ref, name
  355.   my $size = 0;
  356.   map {$size += scalarUsage($_)} @{$_[0]};
  357.   my $len = @{$_[0]};
  358.   print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
  359.     " (data: $size bytes)\n"
  360.       if defined $_[1];
  361.   $CompleteTotal +=  $size;
  362.   $size;
  363. }
  364.  
  365. sub hashUsage {        # hash ref, name
  366.   my @keys = keys %{$_[0]};
  367.   my @values = values %{$_[0]};
  368.   my $keys = arrayUsage \@keys;
  369.   my $values = arrayUsage \@values;
  370.   my $len = @keys;
  371.   my $total = $keys + $values;
  372.   print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
  373.     " (keys: $keys; values: $values; total: $total bytes)\n"
  374.       if defined $_[1];
  375.   $total;
  376. }
  377.  
  378. sub globUsage {            # glob ref, name
  379.   local *name = *{$_[0]};
  380.   $total = 0;
  381.   $total += scalarUsage $name if defined $name;
  382.   $total += arrayUsage \@name, $_[1] if defined @name;
  383.   $total += hashUsage \%name, $_[1] if defined %name and $_[1] ne "main::" 
  384.     and $_[1] ne "DB::";   #and !($package eq "dumpvar" and $key eq "stab"));
  385.   $total;
  386. }
  387.  
  388. sub packageUsage {
  389.   my ($package,@vars) = @_;
  390.   $package .= "::" unless $package =~ /::$/;
  391.   local *stab = *{"main::"};
  392.   while ($package =~ /(\w+?::)/g){
  393.     *stab = $ {stab}{$1};
  394.   }
  395.   local $TotalStrings = 0;
  396.   local $CompleteTotal = 0;
  397.   my ($key,$val);
  398.   while (($key,$val) = each(%stab)) {
  399.     next if @vars && !grep($key eq $_,@vars);
  400.     globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
  401.   }
  402.   print "String space: $TotalStrings.\n";
  403.   $CompleteTotal += $TotalStrings;
  404.   print "\nGrand total = $CompleteTotal bytes\n";
  405. }
  406.  
  407. 1;
  408.  
  409.